home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / generate_y.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  11.2 KB  |  252 lines
  1. (herald (back_end generate_y)
  2.   (env t (orbit_top defs) (back_end closure) (back_end bookkeep)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Copyright (c) 1985 David Kranz
  28.  
  29. ;;; GENERATE-LET&LABELS Divide up the procedures depending on whether they
  30. ;;; need to be closed or can be jumped to.
  31.  
  32. (define (generate-labels node)        
  33.   (destructure (((cont master) (call-args node)))
  34.     (destructure (((body . procs) (call-args (lambda-body master))))
  35.       (xselect (lambda-strategy master)
  36.         ((strategy/heap)
  37.          (set-return-size node master cont)
  38.          (generate-heap-labels node body procs))                                 
  39.         ((strategy/vframe strategy/ezclose)
  40.          (set-stack-return-size node master cont)
  41.          (generate-stack-labels node master))
  42.         ((strategy/label)
  43.          (set-return-size node master cont)))
  44.       (allocate-call (lambda-body body)))))
  45.  
  46.                                               
  47. (define (set-stack-return-size node master cont)
  48.    (set (lambda-live master)                                          
  49.         (if (leaf-node? cont)
  50.             (cons (fx+ (fetch-continuation-from-stack node (leaf-value cont))
  51.                        (closure-size (environment-closure (lambda-env master))))
  52.                   (let ((node (variable-y-lambda (leaf-value cont))))
  53.                     (if (and (node-parent node)
  54.                              (primop-ref? (call-proc (node-parent node)) primop/y))
  55.                         node
  56.                         '())))
  57.             (list (closure-size (environment-closure (lambda-env master)))))))
  58.                                                                   
  59. (define (set-return-size node master cont)
  60.    (set (lambda-live master)                                          
  61.         (if (leaf-node? cont)
  62.             (cons (fetch-continuation-from-stack node (leaf-value cont))
  63.                   (let ((node (variable-y-lambda (leaf-value cont))))
  64.                     (if (and (node-parent node)
  65.                              (primop-ref? (call-proc (node-parent node)) primop/y))
  66.                         node
  67.                         '())))
  68.             '(0))))
  69.                                                                   
  70.  
  71.  
  72. (define (generate-heap-labels node body closures)
  73.     (if closures
  74.         (let ((closure (environment-closure (lambda-env (car closures)))))
  75.           (make-heap-closure node closure)
  76.           (lock AN)
  77.           (walk (lambda (var)
  78.                   (let ((reg (get-register 'pointer node '*))
  79.                         (offset (cdr (assq var (closure-env closure)))))
  80.                     (generate-move-address (reg-offset AN offset) reg)
  81.                     (mark var reg)))
  82.                 (filter (lambda (closure)
  83.                           (memq? closure (lambda-live body)))
  84.                         (cdr (closure-members closure))))
  85.           (unlock AN)
  86.           (if (memq? (car (closure-members closure)) (lambda-live body))
  87.               (mark (car (closure-members closure)) AN)))))
  88.                                                          
  89.                                                          
  90. (define (generate-stack-labels node vframe)
  91.   (cond ((eq? (lambda-strategy vframe) strategy/vframe)
  92.          (make-vframe-closure node 
  93.                               vframe 
  94.                               (environment-closure (lambda-env vframe)))
  95.          (free-register node P)
  96.          (generate-move-address (reg-offset SP 2) P)
  97.          (mark (lambda-self-var vframe) P))
  98.         (else
  99.          (make-vframe-closure node 
  100.                               vframe 
  101.                               (environment-closure (lambda-env vframe))))))
  102.  
  103.  
  104. (define (get-or-set-join-state node lamb)
  105.   (let ((join (lambda-env lamb)))
  106.     (if (eq? (join-point-global-registers join) 'not-yet-determined)
  107.         (set-join-state node join lamb))
  108.     join))
  109.  
  110. ;;; SET-JOIN-STATE The first jump (compile time) is about to be made to this
  111. ;;; point.  We must set up places for the free variables to go.  For now,
  112. ;;; put one in a register and the rest in temporaries. Move them there.
  113.  
  114.  
  115. (define (set-join-state node join lamb)
  116.   (let ((p-ok? (not (join-point-contour-needed? join))))
  117.     (lambda-queue lamb)
  118.     (compute-label-arg-specs node lamb p-ok?)
  119.     (let* ((-args (map car (join-point-arg-specs join)))
  120.        (args (if p-ok? `(,an ,@-args) `(,an ,p ,@-args)))
  121.            (global '()))
  122.       (iterate loop ((vars (join-point-env join)) (left '()))
  123.         (cond ((null? vars)
  124.                (do ((vars left (cdr vars)))
  125.                    ((null? vars))
  126.                  (let ((reg (get-free-register (car vars) args p-ok?)))
  127.                    (push args reg)
  128.                    (push global (cons reg (car vars))))))
  129.               (else
  130.                (let ((w (or (register-loc (car vars))
  131.                             (temp-loc (car vars))
  132.                             (likely-next-reg (car vars) lamb))))
  133.                  (cond ((and (fixnum? w) 
  134.                              (not (memq? w args)))
  135.                         (push args w)
  136.                         (push global (cons w (car vars)))
  137.                         (loop (cdr vars) left))
  138.                        ((register-loc (car vars))
  139.                         => (lambda (reg)
  140.                              (cond ((not (memq? reg args))
  141.                                     (push args reg)
  142.                                     (push global (cons reg (car vars)))
  143.                                     (loop (cdr vars) left))
  144.                                    (else
  145.                                     (loop (cdr vars) (cons (car vars) left))))))
  146.                        (else
  147.                         (loop (cdr vars) (cons (car vars) left))))))))
  148.       (or p-ok? (push global (cons P (join-point-contour join))))
  149.       (set (join-point-global-registers join) global))))
  150.  
  151.  
  152. (define (compute-label-arg-specs node label p-ok?)
  153.   (receive (formals actuals) (if (continuation? label)
  154.                                  (return (lambda-variables label)
  155.                                          (call-args node))
  156.                                  (return (cdr (lambda-variables label))
  157.                                          (cdr (call-args node))))
  158.   (iterate loop ((formals formals) (actuals actuals)
  159.          (args '()) (regs (if p-ok? (list AN) (list P AN))))
  160.     (cond ((null? formals)
  161.            (set (join-point-arg-specs (lambda-env label)) (reverse! args)))
  162.           (else
  163.       (let* ((w (likely-next-reg (car formals) label))
  164.              (reg (cond ((and (fixnum? w)
  165.                   (var-reg-compatable? (car formals) w)
  166.                   (not (memq? w regs)))
  167.              w)
  168.                         ((let ((reg (and (reference-node? (car actuals))
  169.                                          (register-loc (leaf-value (car actuals))))))
  170.                            (if (and reg
  171.                                     (var-reg-compatable? (car formals) reg)
  172.                                     (not (memq? reg regs)))
  173.                                reg 
  174.                                nil)))
  175.                         (else
  176.                          (get-free-register (car formals) regs p-ok?)))))
  177.         (loop (cdr formals)                                    
  178.               (cdr actuals)
  179.               (cons (cons reg (variable-rep (car formals))) args)
  180.               (cons reg regs))))))))
  181.  
  182. (define (var-reg-compatable? var reg)   
  183.   (and (fxn= reg AN)
  184.       (case (variable-rep var)
  185.         ((rep/pointer)
  186.          (select (variable-type var)
  187.            ((type/fixnum type/char) '#t)
  188.            (else (eq? (reg-type reg) 'pointer))))
  189.         (else
  190.          (eq? (reg-type reg) 'scratch)))))
  191.                             
  192. (define (variable-register-type var)
  193.   (case (variable-rep var)
  194.     ((rep/pointer) 
  195.      (select (variable-type var)
  196.        ((type/fixnum type/char) '*)
  197.        (else 'pointer)))
  198.     (else 'scratch)))
  199.                   
  200.   
  201. (define (get-free-register var used p-ok?)
  202.   (really-get-free-register (variable-register-type var) used nil p-ok?))
  203.  
  204. (define (really-get-free-register type used force? p-ok?)
  205.   (xcase type
  206.     ((pointer)
  207.      (iterate loop ((i (if p-ok? P A1)))
  208.        (cond ((fx>= i AN)               
  209.               (cond (force?
  210.                      (do ((j *real-registers* (fx+ j 1)))
  211.                          ((if (fx>= j (fx+ *real-registers* *pointer-temps*))
  212.                               (bug "ran out of registers in GET-FREE-REGISTER")
  213.                               (not (memq? j used)))
  214.                           j)))
  215.                      (else 
  216.                       (really-get-free-register type used t p-ok?))))
  217.              ((memq? i used) (loop (fx+ i 1)))
  218.              ((or force? (not (reg-node i))) i)
  219.              (else (loop (fx+ i 1))))))                        
  220.     ((scratch)
  221.      (iterate loop ((i 0))
  222.        (cond ((fx= i *scratch-registers*)
  223.               (cond (force?
  224.                      (do ((j (fx+ *real-registers* *pointer-temps*) (fx+ j 1)))
  225.                          ((if (fx>= j *no-of-registers*)
  226.                               (bug "ran out of registers in GET-FREE-REGISTER")
  227.                               (not (memq? j used)))
  228.                           j)))
  229.                     (else
  230.                      (really-get-free-register type used t p-ok?))))
  231.              ((memq? i used) (loop (fx+ i 1)))
  232.              ((or force? (not (reg-node i))) i)
  233.              (else (loop (fx+ i 1))))))
  234.     ((*)
  235.      (iterate loop ((i 0))
  236.        (cond ((and (not p-ok?) (fx= i P)) (loop A1))
  237.              ((fx>= i AN)
  238.               (cond (force?
  239.                      (do ((j *real-registers* (fx+ j 1)))
  240.                          ((if (fx>= j *no-of-registers*)
  241.                               (bug "ran out of registers in GET-FREE-REGISTER")
  242.                               (not (memq? j used)))
  243.                           j)))
  244.                     (else
  245.                      (really-get-free-register type used t p-ok?))))
  246.              ((memq? i used) (loop (fx+ i 1)))
  247.              ((or force? (not (reg-node i))) i)
  248.              (else (loop (fx+ i 1))))))))
  249.  
  250.  
  251.  
  252.